home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel-075.lha / feel0.75 / Src / basic.c < prev    next >
C/C++ Source or Header  |  1992-06-18  |  6KB  |  269 lines
  1. /* ******************************************************************** */
  2. /*  basic.c          Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /* Basic functions                                            */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * Change Log:
  9.  *   Version 1, April 1989
  10.  *      Add many functions - JPff
  11.  *      Add rplaca & rplacd - RJB
  12.  *      Add defmacro - JPff
  13.  *      Introduce GC protection in places - JPff
  14.  *    Wrote NREVERSE for fun - JPff
  15.  *    and ASSOC - JPff
  16.  *    Moved basic.c to generic.c - JPff
  17.  *    Add defconstant and mutability in bindings - JPff
  18.  *      Hacked car & cons on the nil case and fixed the consp 
  19.  *         make_module_function so that it didn't refer to cons !! - (25/10/89) KJP
  20.  *      Altered defun so that its body is a list of forms - (25/10/89) KJP
  21.  */
  22.  
  23.  
  24. #include "defs.h"
  25. #include "structs.h"
  26. #include "funcalls.h"
  27.  
  28. #include "error.h"
  29. #include "global.h"
  30.  
  31. #include "modboot.h"
  32. #include "specials.h"
  33. #include "weak.h"
  34.  
  35. EUFUN_1( Fn_atom, form)
  36. {
  37.   return (is_cons(form) ? nil : lisptrue);
  38. }
  39. EUFUN_CLOSE
  40.  
  41. void printoblist(LispObject *stacktop)
  42. {     /* Broke */
  43.   LispObject ob = (LispObject) ObList;
  44.   while (ob!=NULL) {
  45.     EUCALL_2(Fn_print,ob, StdErr);
  46.     ob = (LispObject) (ob->SYMBOL).left;
  47.   }
  48. }
  49.  
  50. EUFUN_0 (Fn_oblist)
  51. {
  52.   printoblist(stacktop);
  53.   return nil;
  54. }
  55. EUFUN_CLOSE
  56.  
  57. EUFUN_1( Fn_consn, n)
  58. {
  59.   int i;
  60.   LispObject l = nil;
  61.  
  62.   for (i = intval(n); i > 0; --i) {
  63.     ARG_1(stacktop) = l;
  64.     ARG_0(stacktop) = nil;
  65.     l = Fn_cons(stacktop);
  66.   }
  67.  
  68.   return(l);
  69. }
  70. EUFUN_CLOSE
  71.  
  72. EUFUN_1( Fn_system, str)
  73. {
  74.   extern int system(char *);
  75.  
  76.   if (!is_string(str))
  77.     CallError(stacktop,"system: not a string",str,NONCONTINUABLE);
  78.  
  79.   (void) system(stringof(str));
  80.  
  81.   return(nil);
  82. }
  83. EUFUN_CLOSE
  84.  
  85. EUFUN_1( Fn_getenv, str)
  86. {
  87.   extern char *getenv(char *);
  88.   extern int strlen(char *);
  89.   char *value;
  90.  
  91.   if (!is_string(str))
  92.     CallError(stacktop,"getenv: not a string",str,NONCONTINUABLE);
  93.  
  94.   value = getenv(stringof(str));
  95.  
  96.   if (value == NULL) return(nil);
  97.  
  98.   return((LispObject) allocate_string(stacktop,value,strlen(value)));
  99. }
  100. EUFUN_CLOSE
  101.  
  102. EUFUN_0( Fn_exit)
  103. {
  104.   fprintf(StdOut->STREAM.handle,"\n\nExiting EuLisp\n\n");
  105.   
  106.   system_lisp_exit(0);
  107.  
  108.   return(nil);
  109. }
  110. EUFUN_CLOSE
  111.  
  112. EUFUN_0( Fn_make_map)
  113. {
  114.   extern void make_description_file(LispObject *);
  115.  
  116.   make_description_file(stacktop);
  117.  
  118.   return(nil);
  119. }
  120. EUFUN_CLOSE
  121.  
  122. /* Time... */
  123.  
  124. #include <sys/types.h>
  125.  
  126. EUFUN_0( Fn_system_time)
  127. {
  128.   extern long time(long *);
  129.   long n;
  130.  
  131.   (void) time(&n);
  132.   return(allocate_integer(stackbase, (int) n));
  133. }
  134. EUFUN_CLOSE
  135.  
  136. EUFUN_0( Fn_process_id)
  137. {
  138.   extern int getpid(void);
  139.   int xx;
  140.   xx = getpid();
  141.   return(allocate_integer(stackbase,xx));
  142. }
  143. EUFUN_CLOSE
  144.  
  145. EUFUN_0( Fn_backtrace)
  146. {
  147.   extern void module_eval_backtrace(LispObject *);
  148.   module_eval_backtrace(stacktop);
  149.   return(nil);
  150. }
  151. EUFUN_CLOSE
  152.  
  153. EUFUN_0( Fn_cpu_time)
  154. {
  155.   extern long clock(void);
  156.   int xx;
  157.   xx=(int)(clock()/10000);
  158.   return(allocate_integer(stackbase,xx));
  159. }
  160. EUFUN_CLOSE
  161.  
  162. EUFUN_0( Fn_rand)
  163. {
  164.   extern int rand(void);
  165.   int n;
  166.   n=rand();
  167.  
  168.   return(real_allocate_integer(stackbase, n));
  169. }
  170. EUFUN_CLOSE
  171.  
  172. EUFUN_1( Fn_srand, s)
  173. {
  174.   extern void srand(unsigned int);
  175.  
  176.   srand((unsigned int) intval(s));
  177.  
  178.   return(nil);
  179. }
  180. EUFUN_CLOSE
  181.  
  182. EUFUN_1( Fn_system_describe, obj)
  183. {
  184.   printf("Address: %x\n",(int) obj);
  185.   printf("Type: %x\n",typeof(obj));
  186.   printf("GC: %x\n",gcof(obj));
  187.   printf("Class: %x\n",(int) classof(obj));
  188.   fflush(stdout);
  189.   return(nil);
  190. }
  191. EUFUN_CLOSE
  192.  
  193. /* Weak pointers... */
  194.  
  195. extern LispObject allocate_weak_wrapper(LispObject*, LispObject);
  196.  
  197. EUFUN_1( Fn_make_weak_wrapper, obj)
  198. {
  199.   LispObject tmp;
  200.   tmp=EUCALL_2(Fn_cons,obj,nil);
  201.   lval_classof(tmp)=Weak_Wrapper;
  202.   lval_typeof(tmp)=TYPE_WEAK_WRAPPER;
  203.   return(tmp);
  204. }
  205. EUFUN_CLOSE
  206.  
  207. EUFUN_1( Fn_weak_wrapper_ref, w)
  208. {
  209.   if (!is_weak_wrapper(w))
  210.     CallError(stacktop,
  211.           "weak-wrapper-ref: not a weak wrapper",w,NONCONTINUABLE);
  212.  
  213.   return(weak_ptr_val(w));
  214. }
  215. EUFUN_CLOSE
  216.  
  217. EUFUN_2 (Fn_weak_wrapper_ref_setter, w, obj)
  218. {
  219.   if (!is_weak_wrapper(w))
  220.     CallError(stacktop,"(setter weak-wrapper-ref): not a weak wrapper",
  221.           w,NONCONTINUABLE);  
  222.  
  223.   weak_ptr_val(w) = obj;
  224.  
  225.   return(obj);
  226. }
  227. EUFUN_CLOSE
  228.  
  229. /* *************************************************************** */
  230. /* Initialisation of this section                                  */
  231. /* *************************************************************** */
  232.  
  233. void initialise_basic(LispObject *stacktop)
  234. {
  235.   LispObject get,set;
  236.   
  237.   (void) make_module_function(stacktop,"special-operator-p",Fn_special_form_p,1);
  238.   get = make_module_function(stacktop,"symbol-dynamic-value",Fn_dynamic,1);
  239.   STACK_TMP(get);
  240.   set = make_unexported_module_function(stacktop,"symbol-dynamic-value-updator",
  241.                     Fn_dynamic_setq,2);
  242.   UNSTACK_TMP(get);
  243.   set_anon_associate(stacktop,get,set);
  244.  
  245.   (void) make_module_function(stacktop,"atom",Fn_atom,1);
  246.   (void) make_module_function(stacktop,"oblist", Fn_oblist, 0);
  247.   (void) make_module_function(stacktop,"consn", Fn_consn, 1);
  248.   (void) make_module_function(stacktop,"system",Fn_system,1);
  249.   (void) make_module_function(stacktop,"getenv",Fn_getenv,1);
  250.   (void) make_module_function(stacktop,"exit",Fn_exit,0);
  251.   (void) make_module_function(stacktop,"make-map",Fn_make_map,0);
  252.   (void) make_module_function(stacktop,"system-time",Fn_system_time,0);
  253.   (void) make_module_function(stacktop,"process-id",Fn_process_id,0);
  254.   (void) make_module_function(stacktop,"backtrace",Fn_backtrace,0);
  255.   (void) make_module_function(stacktop,"cpu-time",Fn_cpu_time,0);
  256.   (void) make_module_function(stacktop,"c-rand",Fn_rand,0);
  257.   (void) make_module_function(stacktop,"c-srand",Fn_srand,1);
  258.  
  259.   (void) make_module_function(stacktop,"system-print",Fn_system_describe,1);
  260.  
  261.   (void) make_module_function(stacktop,"make-weak-wrapper",Fn_make_weak_wrapper,1);
  262.   get = make_module_function(stacktop,"weak-wrapper-ref",Fn_weak_wrapper_ref,1);
  263.   STACK_TMP(get);
  264.   set = make_module_function(stacktop,"(setter weak-wrapper-ref)",
  265.                  Fn_weak_wrapper_ref_setter,2);
  266.   UNSTACK_TMP(get);
  267.   set_anon_associate(stacktop,get,set);
  268. }
  269.